home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xscheme.arc / xscom.c < prev    next >
C/C++ Source or Header  |  1989-01-29  |  33KB  |  1,453 lines
  1. /* xscom.c - a simple scheme bytecode compiler */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7. #include "xsbcode.h"
  8.  
  9. /* size of code buffer */
  10. #define CMAX    4000
  11.  
  12. /* continuation types */
  13. #define C_RETURN    -1
  14. #define C_NEXT        -2
  15.  
  16. /* macro to check for a lambda list keyword */
  17. #define lambdakey(x)    ((x) == lk_optional || (x) == lk_rest)
  18.  
  19. /* external variables */
  20. extern LVAL lk_optional,lk_rest,true;
  21.  
  22. /* local variables */
  23. static LVAL info;        /* compiler info */
  24.  
  25. /* code buffer */
  26. static unsigned char cbuff[CMAX];    /* base of code buffer */
  27. static int cbase;            /* base for current function */
  28. static int cptr;            /* code buffer pointer */
  29.  
  30. /* forward declarations */
  31. int do_define(),do_set(),do_quote(),do_lambda(),do_consstream(),do_delay();
  32. int do_let(),do_letrec(),do_letstar(),do_cond(),do_and(),do_or();
  33. int do_if(),do_begin(),do_while(),do_access();
  34. LVAL make_code_object();
  35.  
  36. /* integrable function table */
  37. typedef struct { char *nt_name; int nt_code,nt_args; } NTDEF;
  38. static NTDEF *nptr,ntab[] = {
  39.     "ATOM",            OP_ATOM,    1,
  40.     "EQ?",            OP_EQ,        2,
  41.     "NULL?",        OP_NULL,    1,
  42.     "NOT",            OP_NULL,    1,
  43.     "CONS",            OP_CONS,    2,
  44.     "CAR",            OP_CAR,        1,
  45.     "CDR",            OP_CDR,        1,
  46.     "SET-CAR!",        OP_SETCAR,    2,
  47.     "SET-CDR!",        OP_SETCDR,    2,
  48.     "+",            OP_ADD,        -2,
  49.     "-",            OP_SUB,        -2,
  50.     "*",            OP_MUL,        -2,
  51.     "QUOTIENT",        OP_QUO,        -2,
  52.     "<",            OP_LSS,        -2,
  53.     "=",            OP_EQL,        -2,
  54.     ">",            OP_GTR,        -2,
  55.     0
  56. };
  57.  
  58. /* special form table */
  59. typedef struct { char *ft_name; int (*ft_fcn)(); } FTDEF;
  60. static FTDEF *fptr,ftab[] = {
  61.     "QUOTE",    do_quote,
  62.     "LAMBDA",    do_lambda,
  63.     "DELAY",    do_delay,
  64.     "LET",        do_let,
  65.     "LET*",        do_letstar,
  66.     "LETREC",    do_letrec,
  67.     "DEFINE",    do_define,
  68.     "SET!",        do_set,
  69.     "IF",        do_if,
  70.     "COND",        do_cond,
  71.     "BEGIN",    do_begin,
  72.     "SEQUENCE",    do_begin,
  73.     "AND",        do_and,
  74.     "OR",        do_or,
  75.     "WHILE",    do_while,
  76.     "ACCESS",    do_access,
  77.     0
  78. };
  79.  
  80. /* xlcompile - compile an expression */
  81. LVAL xlcompile(expr,ctenv)
  82.   LVAL expr,ctenv;
  83. {
  84.     /* initialize the compile time environment */
  85.     info = cons(NIL,NIL); cpush(info);
  86.     rplaca(info,newframe(ctenv,1));
  87.     rplacd(info,cons(NIL,NIL));
  88.  
  89.     /* setup the base of the code for this function */
  90.     cbase = cptr = 0;
  91.  
  92.     /* setup the entry code */
  93.     putcbyte(OP_FRAME);
  94.     putcbyte(1);
  95.  
  96.     /* compile the expression */
  97.     do_expr(expr,C_RETURN);
  98.  
  99.     /* build the code object */
  100.     settop(make_code_object(NIL));
  101.     return (pop());
  102. }
  103.  
  104. /* xlfunction - compile a function */
  105. LVAL xlfunction(fun,fargs,body,ctenv)
  106.   LVAL fun,fargs,body,ctenv;
  107. {
  108.     /* initialize the compile time environment */
  109.     info = cons(NIL,NIL); cpush(info);
  110.     rplaca(info,newframe(ctenv,1));
  111.     rplacd(info,cons(NIL,NIL));
  112.  
  113.     /* setup the base of the code for this function */
  114.     cbase = cptr = 0;
  115.  
  116.     /* compile the lambda list and the function body */
  117.     parse_lambda_list(fargs,body);
  118.     do_begin(body,C_RETURN);
  119.  
  120.     /* build the code object */
  121.     settop(make_code_object(fun));
  122.     return (pop());
  123. }
  124.  
  125. /* do_expr - compile an expression */
  126. LOCAL do_expr(expr,cont)
  127.   LVAL expr; int cont;
  128. {
  129.     LVAL fun;
  130.     if (consp(expr)) {
  131.     fun = car(expr);
  132.      if (!symbolp(fun) || (!in_ntab(expr,cont) && !in_ftab(expr,cont)))
  133.         do_call(expr,cont);
  134.     }
  135.     else if (symbolp(expr))
  136.     do_identifier(expr,cont);
  137.     else
  138.     do_literal(expr,cont);
  139. }
  140.  
  141. /* in_ntab - check for a function in ntab */
  142. LOCAL int in_ntab(expr,cont)
  143.   LVAL expr; int cont;
  144. {
  145.     unsigned char *pname;
  146.     pname = getstring(getpname(car(expr)));
  147.     for (nptr = ntab; nptr->nt_name; ++nptr)
  148.     if (strcmp(pname,nptr->nt_name) == 0) {
  149.         do_nary(nptr->nt_code,nptr->nt_args,expr,cont);
  150.         return (TRUE);
  151.     }
  152.     return (FALSE);
  153. }
  154.  
  155. /* in_ftab - check for a function in ftab */
  156. LOCAL int in_ftab(expr,cont)
  157.   LVAL expr; int cont;
  158. {
  159.     unsigned char *pname;
  160.     pname = getstring(getpname(car(expr)));
  161.     for (fptr = ftab; fptr->ft_name; ++fptr)
  162.     if (strcmp(pname,fptr->ft_name) == 0) {
  163.         (*fptr->ft_fcn)(cdr(expr),cont);
  164.         return (TRUE);
  165.     }
  166.     return (FALSE);
  167. }
  168.  
  169. /* do_define - handle the (DEFINE ... ) expression */
  170. LOCAL do_define(form,cont)
  171.   LVAL form; int cont;
  172. {
  173.     if (atom(form))
  174.     xlerror("expecting symbol or function template",form);
  175.     define1(car(form),cdr(form),cont);
  176. }
  177.  
  178. /* define1 - helper routine for do_define */
  179. LOCAL define1(list,body,cont)
  180.   LVAL list,body; int cont;
  181. {
  182.     LVAL fargs;
  183.     int off;
  184.  
  185.     /* handle nested definitions */
  186.     if (consp(list)) {
  187.     cpush(cons(xlenter("LAMBDA"),NIL));    /* (LAMBDA) */
  188.     rplacd(top(),cons(cdr(list),NIL));    /* (LAMBDA args) */
  189.     rplacd(cdr(top()),body);        /* (LAMBDA args body) */
  190.     settop(cons(top(),NIL));        /* ((LAMBDA args body)) */
  191.     define1(car(list),top(),cont);
  192.     drop(1);
  193.     }
  194.     
  195.     /* compile procedure definitions */
  196.     else {
  197.  
  198.     /* make sure it's a symbol */
  199.     if (!symbolp(list))
  200.         xlerror("expecting a symbol",list);
  201.  
  202.     /* check for a procedure definition */
  203.     if (consp(body)
  204.         &&  consp(car(body))
  205.         &&  car(car(body)) == xlenter("LAMBDA")) {
  206.         fargs = car(cdr(car(body)));
  207.         body = cdr(cdr(car(body)));
  208.         cd_fundefinition(list,fargs,body);
  209.     }
  210.  
  211.     /* compile the value expression or procedure body */
  212.     else
  213.         do_begin(body,C_NEXT);
  214.     
  215.     /* define the variable value */
  216.     if (findcvariable(list,&off))
  217.         cd_evariable(OP_ESET,0,off);
  218.     else
  219.         cd_variable(OP_GSET,list);
  220.     do_literal(list,cont);
  221.     }
  222. }
  223.  
  224. /* do_set - compile the (SET! ... ) expression */
  225. LOCAL do_set(form,cont)
  226.   LVAL form; int cont;
  227. {
  228.     if (atom(form))
  229.     xlerror("expecting symbol or ACCESS form",form);
  230.     else if (symbolp(car(form)))
  231.     do_setvar(form,cont);
  232.     else if (consp(car(form)))
  233.     do_setaccess(form,cont);
  234.     else
  235.     xlerror("expecting symbol or ACCESS form",form);
  236. }
  237.  
  238. /* do_setvar - compile the (SET! var value) expression */
  239. LOCAL do_setvar(form,cont)
  240.   LVAL form; int cont;
  241. {
  242.     int lev,off;
  243.     LVAL sym;
  244.  
  245.     /* get the variable name */
  246.     sym = car(form);
  247.  
  248.     /* compile the value expression */
  249.     form = cdr(form);
  250.     if (atom(form))
  251.     xlerror("expecting value expression",form);
  252.     do_expr(car(form),C_NEXT);
  253.  
  254.     /* set the variable value */
  255.     if (findvariable(sym,&lev,&off))
  256.     cd_evariable(OP_ESET,lev,off);
  257.     else
  258.     cd_variable(OP_GSET,sym);
  259.     do_continuation(cont);
  260. }
  261.  
  262. /* do_quote - compile the (QUOTE ... ) expression */
  263. LOCAL do_quote(form,cont)
  264.   LVAL form; int cont;
  265. {
  266.     if (atom(form))
  267.     xlerror("expecting quoted expression",form);
  268.     do_literal(car(form),cont);
  269. }
  270.  
  271. /* do_lambda - compile the (LAMBDA ... ) expression */
  272. LOCAL do_lambda(form,cont)
  273.   LVAL form; int cont;
  274. {
  275.     if (atom(form))
  276.     xlerror("expecting argument list",form);
  277.     cd_fundefinition(NIL,car(form),cdr(form));
  278.     do_continuation(cont);
  279. }
  280.  
  281. /* cd_fundefinition - compile the function */
  282. LOCAL cd_fundefinition(fun,fargs,body)
  283.   LVAL fun,fargs,body;
  284. {
  285.     int oldcbase;
  286.  
  287.     /* establish a new environment frame */
  288.     oldcbase = add_level();
  289.  
  290.     /* compile the lambda list and the function body */
  291.     parse_lambda_list(fargs,body);
  292.     do_begin(body,C_RETURN);
  293.  
  294.     /* build the code object */
  295.     cpush(make_code_object(fun));
  296.     
  297.     /* restore the previous environment */
  298.     remove_level(oldcbase);
  299.  
  300.     /* compile code to create a closure */
  301.     do_literal(pop(),C_NEXT);
  302.     putcbyte(OP_CLOSE);
  303. }
  304.  
  305. /* parse_lambda_list - parse the formal argument list */
  306. LOCAL parse_lambda_list(fargs,body)
  307.   LVAL fargs,body;
  308. {
  309.     LVAL arg,restarg,new,last;
  310.     int frame,slotn;
  311.     
  312.     /* setup the entry code */
  313.     putcbyte(OP_FRAME);
  314.     frame = putcbyte(0);
  315.  
  316.     /* initialize the argument name list and slot number */
  317.     restarg = last = NIL;
  318.     slotn = 1;
  319.     
  320.     /* handle each required argument */
  321.     while (consp(fargs) && (arg = car(fargs)) && !lambdakey(arg)) {
  322.  
  323.     /* make sure the argument is a symbol */
  324.     if (!symbolp(arg))
  325.         xlerror("variable must be a symbol",arg);
  326.  
  327.     /* add the argument name to the name list */
  328.     new = cons(arg,NIL);
  329.     if (last) rplacd(last,new);
  330.     else setelement(car(car(info)),0,new);
  331.     last = new;
  332.  
  333.     /* generate an instruction to move the argument into the frame */
  334.     putcbyte(OP_MVARG);
  335.     putcbyte(slotn++);
  336.     
  337.     /* move the formal argument list pointer ahead */
  338.     fargs = cdr(fargs);
  339.     }
  340.  
  341.     /*